home *** CD-ROM | disk | FTP | other *** search
/ Mac100% 1998 November / MAC100-1998-11.ISO.7z / MAC100-1998-11.ISO / ｵﾝﾗｲﾝｿﾌﾄ定点観測 / ﾕｰﾃｨﾘﾃｨ / Mops 3.2.sea / Mops 3.2 / Mops ƒ / zModules < prev    next >
Text File  |  1998-06-20  |  24KB  |  989 lines
  1. (*
  2. This file implements relocatable modules.  In installed applications on
  3. the 68k, these became separate code segments, but on the PPC they're
  4. just rolled into the app.  In the development environment, however,
  5. they're the same as on the 68k except that they have a separate
  6. data area (of course), and we keep them locked all the time.  This is
  7. because it's tricky to ensure we only unlock them when it's safe,
  8. especially with the code generator doing method calls doing ?unholdMod.
  9. Also, we really ought to have plenty of memory in the development
  10. environment.
  11.  
  12. Modules live in separate files, and when needed, they're loaded into
  13. two handles (code and data areas).
  14.  
  15. The management of modules is rolled into class Module - each module
  16. we define gets a Module object which lives in the dictionary, and
  17. handles the housekeeping details related to the module files.
  18.  
  19.  
  20. Here's the module file format:
  21.  
  22. Header:
  23.     (offs 0 )    4 bytes        date/time compiled
  24.     (offs 4 )    4 bytes        DirID of source file
  25.     (offs 8 )    4 bytes        self-relative offset to exports table
  26.                             (which follows the code)
  27.     (offs 12)    4 bytes        code size
  28.     (offs 16)    4 bytes        self-relative offset to data start
  29.     (offs 20)    4 bytes        data size
  30.  
  31. Code section
  32.  
  33. Exports table:
  34.     (offs 0 )    4 bytes        offset from header start to first cfa
  35.     (offs 4 )    4 bytes        offset to next cfa
  36.     ...
  37.     (offs n )    4 bytes        -1        marker for end of exports table
  38.  
  39. Data section
  40.  
  41.  
  42. Here's the format of an imported word:
  43.     n bytes        header
  44.     2 bytes        handler code $BD2E
  45.     2 bytes        export table offset for this word
  46.     4 bytes        reloc addr of module object
  47.  
  48. A call to an exported word pushes the xt of the word, then calls
  49. enterMod, which grabs the module addr and export table offset, then
  50. calls the module.
  51. *)
  52.  
  53.  
  54. true    value    CLEANMOD?
  55. false    value    RELEASED?
  56.     0    value    THIS_MOD
  57.     0    value    LAST_MOD
  58.  
  59.     0    value    svCDP
  60.     0    value    svDP
  61.     0    value    svLatest
  62.  
  63.     0    value    start_CDP
  64.     0    value    start_DP
  65.  
  66.     string    $EXP
  67.     string    $CXT
  68.     string    $TMP
  69.     
  70.     file    mod_file
  71.     
  72. forward  LDFROMMOD
  73.  
  74. ¥ variable    SAVE_CONTEXT    8 4 *  allot
  75.  
  76. (*
  77. : UNEVAL    ¥ Puts things back to normal after an EVAL"
  78.     evSvDP  0EXIT        ¥ Out if we're not compiling an eval"
  79.     evSvLatest -> latest
  80.     evSvDP -> DP  0 -> evSvDP
  81.     nil?: $evCxt  NIF  ptr: $evCxt  context  32 cmove  release: $evCxt  THEN
  82. ;
  83. *)
  84.  
  85. : UNMOD            ¥ Puts things back to normal after a module
  86.                 ¥ or stand-alone code compilation or eval"
  87. ¥    unEval
  88.     svCDP  0EXIT        ¥ Out if we're not compiling a module/SA
  89.     svLatest -> latest
  90.     svCDP -> CDP  svDP -> DP
  91.     0 -> svCDP  0 -> svDP  0 -> compMod
  92.     nil?: $cxt  NIF  ptr: $cxt  context  32  cmove  release: $cxt  THEN
  93.     false -> SAcomp?
  94. ;
  95.  
  96. : >NXTEXP    ¥ ( cfa -- )  Adds the next cfa offset to the string $exp
  97.             ¥  which will become the exports table.
  98.     start_CDP -  pad !  pad 4  add: $exp  ;
  99.  
  100.  
  101.  
  102. (*    COMPIMP  ( ^mod -- )  compiles the dic entry for an imported word,
  103.     as defined in the construct
  104.     FROM <modName> IMPORT{ name0 name1 ... }
  105.     ^mod is the data address of the module object.
  106.     For name0, say, we compile a header, then a 2-byte self-relative
  107.     offset back to the module object itself, then a 2-byte field
  108.     which is initially zero, but gets filled in when we compile the
  109.     module, and set to the offset within the module's export table
  110.     for the entry for name0.
  111. *)
  112.  
  113. : COMPIMP  { ^mod -- }
  114.     header
  115.     $ BD2E codeW,            ¥ handler code for imported_h
  116.     0 codeW,                ¥ space for export table offset 
  117.     ^mod relocCode,            ¥ ptr to module
  118. ;
  119.  
  120.  
  121. ¥ Note: MLOCAL is still (29-7-97) not working properly, so I'll
  122. ¥  make these into Values, temporarily:
  123.  
  124. 0    value    thisImp
  125. 0    value    thisCfa
  126. ¥ 0    value    maddr
  127.  
  128.  
  129. :class    MODULE    super{ object }
  130.  
  131. record
  132. {    handle    modHdl
  133.     uint    SEG#
  134.     byte    FLAGS
  135.     int        RES#
  136.     int        #IMP
  137.     dicaddr    LASTIMP
  138.     var        DicDateTime
  139.     int        RELOFFS
  140.     bool    INSTALL?
  141. }
  142.  
  143. :m PRINT:
  144.     ." modHdl    "     get: modHdl  dup nilH =
  145.     IF        drop ." (not loaded)"
  146.     ELSE    .h  ." -> "  ptr: modHdl .h
  147.     THEN  cr
  148.     ." seg#      "  print: seg#        cr
  149.     ." flags     "  print: flags    cr
  150.     ." install?  "  print: install?    cr
  151. ;m
  152.  
  153. :m BASE:
  154.     nil?: modHdl  IF  0  EXIT  THEN
  155.     nptr: modHdl  ;m
  156.  
  157. :m HANDLE:    get: modHdl  ;m
  158.  
  159. :m EXEC_CNT:    99  ;m            ¥ not used on PPC
  160.  
  161. :m SETRELEASE:    ¥ ( addr -- )
  162.     modcode -  put: relOffs  ;m
  163.  
  164. :m SETRESID:    ¥ ( resID -- )
  165.     put: res#  ;m
  166.  
  167. :m INSTALL?:    get: install?  ;m
  168.  
  169. :m SETINSTALL:  { instl? ¥ ^ST -- }
  170.     instl?  put: install?
  171.     get: seg# segTable_entry  -> ^ST
  172.     instl? 1 and
  173.     dup  1 ^ST creplace  1 ^ST 8 + creplace
  174. ;m
  175.  
  176.  
  177. ¥ KLUDGE: and UNKLUDGE: may be used when we save a dic image, to mark
  178. ¥ a module as unloaded in the saved image without really unloading it.
  179.  
  180. ¥ :m KLUDGE:    ¥ ( -- modHdl flags exec+locked? )
  181. ¥    get: modHdl  get: flags  addr: exec_cnt  w@  nilH  put: modHdl  ;m
  182.  
  183. ¥ :m UNKLUDGE:    ¥ ( modHdl flags exec+locked? -- )
  184. ¥    addr: exec_cnt  w!  put: flags  put: modHdl  ;m
  185.  
  186. :m EXTNAME:  { xaddr xlen ¥ len -- addr' len' }
  187.     getName: self  -> len   pad len cmove
  188.     xaddr  pad len +  xlen  cmove        ¥ Add extension
  189.     pad  len xlen +  ;m
  190.  
  191. :m BINNAME:    ¥ ( -- addr len )  Returns name of binary file for module.
  192.     " .PBIN" extName: self  ;m
  193.  
  194. :m TXTNAME:    ¥ ( -- addr len )  Returns name of text file for module.
  195.     " .TXT" extName: self  ;m
  196.  
  197.  
  198. :m LOAD:  { ¥ rc modstart ^ST -- }        ¥ Loads if not loaded already
  199.     instld?                            ¥ if installed, mods are always loaded
  200.     IF
  201.         get: seg# segTable_entry   -> ^ST
  202.         ^ST 4+ @  nilP =  IF $ dead  db THEN
  203.         EXIT
  204.     THEN
  205.  
  206.     nil?: modHdl  0EXIT
  207.  
  208. ¥    get: res#
  209. ¥    IF    'type CODE  get: res#  getRes  dup 0= ?error 138
  210. ¥        put: modHdl
  211. ¥    ELSE
  212.         binName: self  name: mod_file  0 setVref: mod_file
  213.         openReadOnly: mod_file  ?error 138
  214.     ¥    ['] pause 4+ @  0 -> pause        ¥ Disable pause over read to avoid
  215.     ¥                                    ¥  possible reentrancy
  216.         size: mod_file  dup  new: modHdl
  217.         lock: modHdl                    ¥ Maybe we need this
  218.         ptr: modHdl  swap  read: mod_file  -> rc
  219.     ¥    ['] pause 4+ !                    ¥ Restore pause
  220.         unlock: modHdl                    ¥ Unlock before error check
  221.         close: mod_file  drop  rc ?error 141
  222.         base: self @  get: dicDateTime  u<
  223.         IF                                ¥ BIN file is old version
  224.             release: modHdl  148 die
  225.         THEN
  226. ¥    THEN
  227.     moveHi: modHdl                        ¥ Move module hi since it gets locked
  228.     lock: modHdl
  229.     
  230. ¥ now we update the ST entries for the code and data segments:
  231.  
  232.     nptr: modHdl  -> modstart
  233.     get: seg# segTable_entry   -> ^ST
  234.     modstart                        ¥ code start
  235.     ^ST 4+ !
  236.     modstart 12 + @                    ¥ code size
  237.     ^ST @ $ FF000000 and or
  238.     ^ST !
  239.     modstart 16 + dup @ +            ¥ data start
  240.     ^ST 12 + !
  241.     modstart 20 + @                    ¥ data size
  242.     ^ST 8 + @ $ FF000000 and or
  243.     ^ST 8 + !
  244.  
  245. ¥ now we must fix the icache:
  246.     modstart dup 12 + @  fix_caches
  247. ;m
  248.  
  249.  
  250. :m LOAD_FOR_EXECUTION:  ( -- ptr )
  251.     instld?                            ¥ if installed, mods are always loaded
  252.     IF
  253.         get: seg#  segTable_entry  4+ @
  254.         dup nilP =  IF $ beef  db THEN  EXIT
  255.     THEN
  256.  
  257.     nil?: modHdl  IF  load: self  THEN
  258.     ptr: modHdl
  259. ;m
  260.  
  261. :m FINISHED_EXECUTION:
  262. ;m
  263.  
  264.  
  265. :m RELEASE:  { ¥ svModcode -- }
  266.     instld?  ?EXIT
  267.     release: modHdl
  268.     get: seg#  make_seg_absent
  269. ;m
  270.  
  271.  
  272. (*
  273. KEEP: and DROP: flag this module as needed and not needed, respectively.
  274. The main purpose of this flagging is that if GETSPACE is called, loaded
  275. modules will be released to make room, unless they have been flagged as
  276. needed by KEEP:.  But note that RELEASE: ignores the flag, so that we
  277. can get rid of a module by force if necessary.  This may happen if there
  278. was a crash while the module was executing.
  279.  
  280. LOCK: is more drastic than KEEP:, since it means that this module becomes
  281. non-relocatable.  UNLOCK: reverses a LOCK:.  Note that DROP: in effect does
  282. an UNLOCK: as well.
  283.  
  284. This "locking" feature is used for ExtrasMod, which has a window, and
  285. for the debugger and printMod, which can be entered through the back
  286. door (via a vect or a trap).  (By the way, we hope we won't have to do this
  287. back door business anywhere else.  Entering a module through the back door
  288. is not usually a very safe thing to do.)
  289.  
  290. Locking a module can give a useful performance improvement if a module is to
  291. be called several times in succession, since we bypass the _HLock and _Hunlock
  292. calls if the module is marked locked.
  293. *)
  294.  
  295. :m KEEP:
  296.     2  addr: flags  cset  ;m
  297.  
  298. :m DROP:
  299. ¥    get: exec_cnt NIF  unlock: modHdl  THEN      ¥ Unlock if not executing
  300.     2  addr: flags creset  ;m
  301.  
  302. :m LOCK:
  303.     load: self
  304. ;m
  305.  
  306. :m UNLOCK:
  307. ¥    false  put: locked?
  308. ¥    get: exec_cnt NIF  nil?: modHdl NIF  unlock: modHdl  THEN THEN
  309. ;m
  310.  
  311. :m KEEP?:
  312.     get: flags  ;m
  313.  
  314. :m LOCKED?:
  315.     true  ;m
  316.  
  317.  
  318. :m ?RELEASE:
  319. ¥    keep?: self  ?EXIT
  320. ¥    release: self
  321. ;m
  322.  
  323. :m #IMP:    get: #imp  ;m
  324.  
  325. :m getMarkerName:    ¥ ( -- )  gets the marker name for the this
  326.                     ¥  module into the string $tmp.  We use this
  327.                     ¥  marker to temporarily forget the part of the
  328.                     ¥  dic above the module declaration, so we can
  329.                     ¥  compile the module in that environment.
  330.     " m__" put: $tmp
  331.     getName: self  add: $tmp
  332. ;m
  333.  
  334.  
  335. :m GETIMPORTS:  { ¥ n -- }
  336.     0 -> n
  337.     BEGIN
  338.         ^base compimp  1 ++> n
  339.         & }  endlist?
  340.     UNTIL
  341.     n  put: #imp
  342.     latest  name>  put: lastimp
  343.     getMarkerName: self  begin: $tmp
  344.     " marker " insert: $tmp
  345.     all: $tmp  evaluate        ¥ "marker m__<module name>"
  346.     release: $tmp
  347. ;m
  348.  
  349.  
  350. ¥                ===================================
  351. ¥                        Module compilation
  352. ¥                ===================================
  353.  
  354. private
  355.  
  356. :m ExpSupers:  { ^nw ¥ relocAddr -- }
  357.     BEGIN
  358.         ^nw @ -> relocAddr
  359.         relocAddr  0EXIT
  360.         relocAddr 24 >>
  361.         get: seg# =                ¥ look at reloc addr seg#
  362.         IF                        ¥ we haven't gone out-of-segment yet, so this
  363.                                 ¥  superclass is in the module, and has to
  364.                                 ¥  be included.
  365.             ^nw @abs 2+            ¥ get to start of methods area in class info
  366.             8 FOR                ¥ go through the 8 method threads
  367.                 dup displace  i expMethods: [self]
  368.                 4+
  369.             NEXT  drop
  370.         THEN
  371.         4 ++> ^nw
  372.     AGAIN  ;m
  373.  
  374. public
  375.             ¥ This gets called via a late bind, so must be public
  376.  
  377. :m ExpMethods:  { maddr thread# -- }
  378.     BEGIN                ¥ Loop thru methods in this class
  379.         maddr @ 0>=
  380.         IF                ¥ We've come to the superclasses - we only
  381.                         ¥  have to handle these once, of course - and
  382.                         ¥  since the order in the export table is
  383.                         ¥  immaterial, we'll just do it if we're on
  384.                         ¥  thread zero.
  385.             thread#
  386.             NIF  maddr  expSupers: self
  387.             THEN  EXIT
  388.         THEN
  389.                     ¥ Next method
  390.         maddr 14 +  ( cfa of method )  >nxtExp
  391.         maddr 4+ displace  -> maddr
  392.     AGAIN  ;m
  393.  
  394. private
  395.  
  396. ¥ &&&&&&&  MLOCAL not working yet - defer to next version
  397.  
  398. ¥ mlocal !exports: { ¥ thisImp thisCfa maddr -- }
  399.  
  400. :m ?!class:    ¥ If this exported item is a class, we set the handler
  401.             ¥ code of the imported version and add the method entry offsets
  402.             ¥ to the export table.
  403.  
  404.     thisCfa 2- w@ $ BC1D =  0EXIT    ¥ Out if it isn't a class
  405.     $ BC2D  thisImp 2- w!            ¥ set handler of imported word
  406.     2  thisCfa ffa 1+ cset
  407.     thisCfa 2+                ¥ get to start of methods area in class info
  408.     8 FOR                    ¥ go through the 8 method threads
  409.         dup displace  i expMethods: self
  410.         4+
  411.     NEXT  drop  ;m
  412.  
  413.  
  414. :m 1export:
  415.     next: theMark  link> -> thisImp
  416.     thisImp  >name n>count  sFind  NIF 999 die  THEN
  417.     -> thisCfa
  418.     thisCfa thisImp =
  419.     IF                                        ¥ Not defined
  420.         cr thisImp .id  2 spaces  144 die
  421.                                     ¥ "You forgot to define this exported name"
  422.         false -> cleanMod?
  423.     ELSE                            ¥ All OK. Put info into import definition:
  424.         thisCfa >name c@  thisImp >name c!    ¥ Name flags
  425.         pos: $exp  thisImp w!                ¥ Export table offset
  426.         thisCfa >nxtExp                        ¥ Add next exp tbl entry
  427.         ?!class: self                        ¥ More stuff if it's a class
  428.     THEN  ;m
  429.  
  430.  
  431. ¥ :mloc !exports:        ¥ { ¥ n thisImp thisCfa maddr -- }
  432. :m !exports:
  433.     get: #imp  0= ?error 143            ¥ Module has no exported names
  434.     clear: $exp
  435.     get: lastimp  set: theMark
  436.     get: #imp  FOR  1export: self  NEXT
  437.     -1 pad !  pad 4 add: $exp            ¥ marker at end of table
  438. ¥ ;mloc
  439. ;m
  440.  
  441.  
  442. (*
  443. FixLinks: fixes up the dictionary links within the compiled module.  We may
  444. want to find words in the module at run time via FIND, but the problem is that
  445. dic links are relative, not relocatable.  This makes FIND fast, but leads
  446. to a problem at run time when the the module is disconnected from the main
  447. dictionary.  If we didn't do anything, we wouldn't know where to start
  448. searching from, and if the search failed, the last link would point into
  449. outer space.
  450. So what we do is to add a snapshot of CONTEXT to the end of the module to give
  451. a place to start from, and to clear the lowest link on each thread to zero (which
  452. means the end).
  453. *)
  454.  
  455. :m FixLinks:  { ¥ link prevLink -- }
  456.     #threads FOR
  457.         context  i cells +  -> link
  458.         BEGIN
  459.             link -> prevLink
  460.             link displace -> link
  461.             link start_CDP u<
  462.         UNTIL
  463.         0 prevLink !
  464.     NEXT
  465. $ c0c0c0c0 code,
  466.     CDP 4+ context -  code,        ¥ adjustment value for context copy
  467.     context 32  codeN,            ¥ add copy of Context to end of code area
  468. ;m
  469.  
  470. :m GoodCompile:  { ¥ code_size data_size -- }
  471.     CDP  start_CDP 8 +  displ!            ¥ store export table offs in header
  472.     all: $exp  codeN,
  473.                                         ¥ add export table to end
  474.     fixLinks: self                        ¥ fix dic links in module
  475.  
  476.     CDP start_CDP -  -> code_size        ¥ size of code (including export table)
  477.     DP  start_DP  -  -> data_size        ¥ size of data
  478.     code_size  start_CDP 12 + !            ¥ store code size in header
  479.     
  480.     start_CDP code_size +                ¥ where data will start
  481.     start_CDP 16 + displ!                ¥ add offs to data start
  482.     data_size  start_CDP 20 + !            ¥ and data size
  483.  
  484.     binName: self  name: mod_file            ¥ Set name of binary file
  485.     create: mod_file  ?error 139
  486.     'type PBIN  'type Mopp  set: mod_file        ¥ type and signature
  487.     start_CDP  code_size  write: mod_file        ¥ write out code, leave err code
  488.     start_DP   data_size  write: mod_file or    ¥ write out data, 'or' err code
  489.     close: mod_file  drop
  490.     IF    msg# 140                        ¥ I/O error on writing bin file
  491.     ELSE
  492.         curs?  -curs
  493.         cr  getName: mod_file type  ."  saved" cr
  494.         -> curs?
  495.     THEN
  496. ;m
  497.  
  498. public
  499.  
  500. :m COMPILE:  ( -- )
  501.     compMod  ?error 177                    ¥ Error if already compiling a module
  502.     release: self                        ¥ Get rid of old version, if loaded
  503.     context 32  put: $cxt                ¥ save CONTEXT and other things, since
  504.     CDP -> svCDP  DP -> svDP            ¥  we're going to do a temporary forget
  505.     latest -> svLatest
  506.     ^base -> compMod
  507.     getMarkerName: self
  508.     all: $tmp  evaluate                    ¥ execute the marker, forgetting back to just
  509.     release: $tmp                        ¥  after the module declaration
  510.     
  511.     svCDP -> CDP  svDP -> DP
  512.  
  513.     true -> cleanMod?
  514.     pushNew: loadFile
  515.     txtName: self  name: topFile
  516.     CDP -> start_CDP  DP -> start_DP
  517.     24  code_reserve            ¥ Reserve space for header and offset to exports table.
  518.     ^base -> this_mod
  519.  
  520.     get: seg#  -> comp_seg#
  521.     start_CDP  start_DP  get: seg#  ldFromMod
  522.     0 -> comp_seg#
  523.  
  524.     dateTime  start_CDP !                ¥ Put compiled date in bin module header
  525.     getDirID: topFile  start_CDP 4+ !    ¥ Also DirID of source file
  526.     drop: loadfile
  527.     0 -> this_mod
  528.     !exports: self
  529.     cleanMod?
  530.     IF    goodCompile: self            ¥ Everything's OK.  Do final housekeeping
  531.     THEN
  532.     unmod                            ¥ Also releases $cxt
  533.     release: $exp  ;m
  534.  
  535.  
  536. ¥ FIND: works like FIND, but just searches for a word in this module.
  537.  
  538. :m FIND: { s255 ¥ thrdOffs modCxt cxtOffs -- cfa T | -- s255 F }
  539.     load: self
  540.     s255                                    ¥ leave on stack for (find)
  541.     dup c@ 7 and 4*  -> thrdOffs            ¥ like what THREAD does
  542.     ptr: modHdl  dup 12 + @ +  32 -  -> modCxt
  543.     modCxt 4- @  -> cxtOffs
  544.     modCxt thrdOffs +  displace
  545.     dup NIF            ¥ thread is empty
  546.         drop false  EXIT
  547.     THEN
  548.     cxtOffs -
  549.     ( s255 1st-link )  (find)
  550. ;m
  551.  
  552. :m CLASSINIT:
  553.     -1  put: relOffs
  554.     dateTime put: dicDateTime
  555.     get_free_seg_pair   put: seg#  drop
  556. ;m
  557.  
  558. ;class
  559.  
  560.  
  561. (*
  562. ENTERMOD ( xt -- )  calls a word in a module.  The passed-in xt is of
  563. the IMPORTED word (i.e. probably in the main dictionary).
  564.  
  565. Here's the format of an imported word:
  566.     n bytes        header
  567.     2 bytes        handler code $BD2E
  568.     2 bytes        export table offset for this word
  569.     4 bytes        reloc addr of module object
  570.  
  571. We arrive at imported_h in cg6 when a call to an imported word has
  572. to be compiled.  We there compile a push of the xt of the word, then
  573. a call to enterMod, which does the main work.  We put enterMod here 
  574. in zModules, since it has to do a late-bound call to the module
  575. object, and this is much easier if it's not in the target
  576. compilation, and is also quicker to debug.
  577. *)
  578.  
  579. : (loadMod)  { xt ¥ xt' ^mod modstart EToffs -- xt' ^mod modstart }
  580.  
  581.     xt 2+ @abs -> ^mod            ¥ get addr of module
  582.     xt w@x  -> EToffs            ¥ and export table offset
  583.     ^mod load_for_execution: class_as> module
  584.     -> modstart
  585.     modstart 8 + dup @ +        ¥ addr of export table
  586.     EToffs + @                    ¥ module-relative offs to word's xt
  587.     modstart +  -> xt'            ¥ xt of word in module
  588.     xt' ^mod modstart
  589. ;
  590.  
  591.  
  592. :f ENTERMOD  { xt ¥ xt' ^mod modstart svMC svMD svMS moddata_start -- }
  593.  
  594.     xt (loadmod)  -> modstart  -> ^mod  -> xt'
  595.  
  596.     modCode -> svMC  modData -> svMD  mod_seg# -> svMS
  597.     ^mod 4+ w@   -> mod_seg#
  598.  
  599.     modstart 16 + dup @ +            ¥ data start
  600.     -> moddata_start
  601.     
  602.     modstart half_displ_range +  -> modcode
  603.     moddata_start half_displ_range +  -> moddata
  604.  
  605. ¥ now we actually call the word in the module
  606.     xt' execute
  607.  
  608. ¥ now we restore everything:
  609.     svMC -> modcode  svMD -> moddata  svMS -> mod_seg#
  610.     ^mod  finished_execution: class_as> module 
  611. ;f
  612.  
  613.  
  614. :f (meth_in_mod)  { ^obj xt modstart seg# ¥ svMC svMD svMS moddata_start -- }
  615.  
  616.     modCode -> svMC  modData -> svMD   mod_seg# -> svMS
  617.  
  618.     seg# -> mod_seg#
  619.  
  620.     modstart 16 + dup @ +            ¥ data start
  621.     -> moddata_start
  622.     
  623.     modstart half_displ_range +  -> modcode
  624.     moddata_start half_displ_range +  -> moddata
  625.  
  626. ¥ now we actually call the method in the module
  627.     ^obj -> rY  xt execute
  628.  
  629. ¥ now we restore everything:
  630.     svMC -> modcode  svMD -> moddata  svMS -> mod_seg#
  631. ;f
  632.  
  633.  
  634. :f enter_meth_in_mod  { ^obj ^mod EToffs ¥ xt modstart -- }
  635.  
  636.     ^mod load_for_execution: class_as> module
  637.     -> modstart
  638.     modstart 8 + dup @ +        ¥ addr of export table
  639.     EToffs + @                    ¥ module-relative offs to word's xt
  640.     modstart +  -> xt            ¥ xt of method in module
  641.     
  642.     ^obj xt modstart  ^mod 4+ w@  (meth_in_mod)
  643.  
  644.     ^mod  finished_execution: class_as> module 
  645. ;f
  646.  
  647.  
  648. (* ****
  649. :f ?enterHeldMod  { ¥ moddata_start -- }
  650.     heldMod  0EXIT
  651.  
  652.     heldModstart 16 + dup @ +            ¥ data start
  653.     -> moddata_start
  654.     
  655.     heldModstart half_displ_range +  -> modcode
  656.     moddata_start half_displ_range +  -> moddata
  657.  
  658. ;f
  659.  
  660.  
  661. :f init_in_mod  { ^class ^obj ¥ xt offs
  662.                     svMC svMD svMCS svMCL svMDS svMDL -- }
  663.  
  664.     ¥ Performs CLASSINIT: method on an object whose class is exported.
  665.     ¥ The module is already held, and ^class is the in-module addr,
  666.     ¥  but the base regs aren't set up.  Very similar to (meth_in_mod),
  667.     ¥  but we look up the method here since we need to bypass the
  668.     ¥  fully general lookup.
  669.     
  670.     initID  ^class  MFA_offset  true  (findm)
  671.     drop                        ¥ is guaranteed to find CLASSINIT: method
  672.     -> xt  -> offs
  673.     offs ++> ^obj                ¥ modify obj addr by offs (needed in case
  674.                                 ¥  method is defined in any superclass
  675.                                 ¥  but the first)
  676.  
  677.     ^obj xt heldmodstart  heldMod 4+ w@  (meth_in_mod)
  678.  
  679.     heldMod  finished_execution: class_as> module 
  680. ;f
  681.  
  682. **** *)
  683.  
  684.  
  685. :f holdMod  { xt ¥ xt' -- xt' }
  686.     xt (loadmod)  -> heldModStart  -> heldMod  -> xt'
  687.     xt'
  688. ;f
  689.  
  690.  
  691. ¥ :f unHoldMod
  692. ¥    0 -> heldMod
  693. ¥ ;f
  694.  
  695.  
  696. :f LDFROMMOD { code_start data_start seg#
  697.     ¥ svMC svMD svCS ^ST svModcode_comp_start svModdata_comp_start -- }
  698.  
  699.         ¥ Load from a module.  We save and restore the current
  700.         ¥ base address values, in case the load changes them.
  701.         ¥ We also come here when compiling a module.
  702.  
  703.     modcode -> svMC  moddata -> svMD  ¥ comp_seg# -> svCS
  704.     modcode_comp_start -> svModcode_comp_start
  705.     moddata_comp_start -> svModdata_comp_start
  706.  
  707.     code_start half_displ_range +  -> modcode
  708.     data_start half_displ_range +  -> moddata
  709.     
  710.     code_start -> modcode_comp_start
  711.     data_start -> moddata_comp_start
  712. ¥    seg#  -> comp_seg#
  713.     
  714.     seg# segTable_entry  -> ^ST
  715.     code_limit CDP -
  716.     ^ST @ $ FF000000 and or  ^ST !            ¥ dummy max code length
  717.     code_start  ^ST 4+ !
  718.     data_limit DP -
  719.     ^ST 8 + @ $ FF000000 and or  ^ST 8 + !    ¥ dummy max data length
  720.     data_start  ^ST 12 + !
  721.  
  722.     loadtop
  723.  
  724.     svMC -> modcode  svMD -> moddata  ¥ svCS -> comp_seg#
  725.     svmodcode_comp_start -> modcode_comp_start    
  726.     svmoddata_comp_start -> moddata_comp_start
  727. ;f
  728.  
  729.  
  730. : SETRELEASE    ¥ ( addr -- )
  731.     setRelease: [ this_mod ]  ;
  732.  
  733. ¥ : MLD
  734. ¥    dup  load: []  ;
  735.  
  736. ¥ ' mld -> modLoad
  737.  
  738. :f MOD?        ¥ ( cfa -- cfa b )
  739.     dup 2- w@  $ BC0B =  NIF  false  EXIT  THEN        ¥ out if not an object
  740.     dup >obj >classXt  ['] module  =  ;f
  741.  
  742.  
  743. : ?DISP  { theCfa size -- }        ¥ handler to release selected modules
  744.     theCfa mod?  NIF  drop  EXIT  THEN
  745.     free size <            ¥ Do we still need space?
  746.     IF    >obj  ?release: module
  747.     ELSE    drop
  748.     THEN  ;
  749.  
  750.  
  751. ¥ PURGE forcibly releases all modules, no matter what.  I'm not sure
  752. ¥  this isn't obsolete.
  753.  
  754. : (PRG)  { theCfa size -- }    ¥ unlock and release
  755.     theCfa mod? NIF  drop  EXIT  THEN
  756.     >obj release: class_as> module  ;
  757.  
  758. : PURGE    ['] (prg)  big#  trav  ;
  759.  
  760.  
  761. : NEEDSPACE    ¥ ( #bytes -- ) release modules until #bytes are available
  762.     false -> released?
  763.     freeblk drop  ['] ?disp swap trav  ;
  764.  
  765. : GS    big# needSpace  released?  ;
  766.  
  767. ' gs -> getSpace
  768.  
  769.  
  770. : FROM        ¥ ( -- ^mod sec# )
  771.     module                            ¥ Create module object
  772.     latest name> >obj  dup -> last_mod  28  ;
  773.  
  774.  
  775. : IMPORT{    ¥ ( ^mod sec# -- )
  776.     28 ?pairs  getImports: []
  777. ;
  778.  
  779. : EXPORTS_CLASS
  780.     last_mod  exports_class: []
  781. ;
  782.  
  783.  
  784.  
  785. testing?
  786. [IF]
  787.  
  788. : QQ    ." The right QQ!" cr  ;
  789.  
  790. from TESTMOD  import{ AA BB CC DD export_class }
  791.  
  792. : QQ    ." This is the wrong QQ!!!"  ;        ¥ This one shouldn't!
  793.  
  794. compile: testmod
  795.  
  796. from TESTMOD2  import{ EE }
  797. compile: testmod2
  798.  
  799. +echo
  800.  
  801. export_class EEE
  802.  
  803.  
  804. : h mword hash 0 mfa_offset ;
  805.  
  806. : LOOKFOR    Mword  find: testmod  ;
  807.  
  808. ¥ endload                ¥ when testing the early stuff, we bail out here
  809.  
  810. [THEN]
  811.  
  812.  
  813. ¥ Now that's done, the next thing we need to do is set up our HFS file
  814. ¥ access:
  815.  
  816. from PATHSMOD    import{  OWP  GETPATHS  .PATHS  }
  817.  
  818. :f OPEN_WITH_PATHS    OWP  ;f
  819.  
  820. compile: pathsMod
  821.  
  822. true -> use_paths?
  823. " mops.paths"  getPaths
  824.  
  825.  
  826. ¥ Right, we now have HFS paths, so we can access our source files in
  827. ¥ different folders.
  828.  
  829. from CALL1&LMOD    import{  CallFirst  CallLast  (GET)  (C1)  (CL)  }
  830.  
  831. ' (get) -> get1st&last
  832. ' (C1)  -> doCall1st
  833. ' (CL)  -> doCallLast
  834.  
  835. compile: call1&Lmod
  836.  
  837.  
  838. 0    value        CASE_TYPE
  839.  
  840. from zCASEMOD     import{  case[ ]=> ], range]=> range], default=> ]case
  841.                             select[  ]select }
  842. compile: zCaseMod
  843.  
  844. : SELECT{    postpone select[  ;        immediate
  845. : }SELECT    postpone ]select  ;        immediate
  846. : IS{        postpone ]=>      ;        immediate
  847. : }END        postpone [          ;        immediate
  848. : DEFAULT{    postpone ]  postpone default=>  postpone drop  ;    immediate
  849.  
  850.  
  851. (* ****
  852. +echo
  853.  
  854. ¥ Torture tests for CASE[ etc - something as complicated as that needs
  855. ¥ a bit of systematic testing...
  856.  
  857. : q
  858.     select[    3 ]=> 23
  859.           [ 2 ]=> 22
  860.           [ 0 ]=> 20
  861.           [ 8 ]=> 28
  862.     default=> 999
  863.     ]select  ;
  864.  
  865. : qq
  866.     case[ 21 ]=> 210
  867.         [ 22 ]=> 220
  868.         [ 80 ], [ 82 ], [ 84 ], [ 86 ]=> 888
  869.         [ 30 40 range]=> 333
  870.         [ 90 ], [ 92 ], [ 170 ]=> -999
  871.         [ 90 ], [ 92 ], [ 100 150 range], [ 170 ]=> -999
  872.         [ 222 ]=>  2220
  873.       default=> 99
  874.      ]case  ;
  875.  
  876.  
  877. : ?CHK
  878.     2dup <>
  879.     IF    cr .h cr .h
  880.         true abort" check FAILED!!!"        ¥ error if something doesn't
  881.                                             ¥  give what we expect
  882.     ELSE
  883.         2drop
  884.     THEN
  885. ;
  886.  
  887.  
  888. 21 qq  210 ?chk
  889. 22 qq  220 ?chk
  890. 80 qq  888 ?chk
  891. 84 qq  888 ?chk
  892. 85 qq  99  ?chk  85 ?chk
  893. 35 qq  333 ?chk
  894. 92 qq  -999 ?chk
  895. 120 qq -999 ?chk
  896. 170 qq -999 ?chk
  897. 222 qq 2220 ?chk
  898. 9999 qq 99 ?chk 9999 ?chk
  899.  
  900. 3 q        23    ?chk
  901. 2 q        22    ?chk
  902. 8 q        28    ?chk
  903. 6 q        999    ?chk  6 ?chk
  904. -1 q    999    ?chk  -1 ?chk
  905. 9  q    999    ?chk  9 ?chk
  906.  
  907.  
  908. ¥ torture tests WORKED!
  909.  
  910. endload
  911.  
  912. ***** *)
  913.  
  914.  
  915. from pasmMod import{    :PPC_code  ;PPC_code
  916.                         disasm  disasm_word  disasm_xt
  917.                         disasm_rng  disasm_cnt  disasm_one
  918.                         set_disasm_call_range  }
  919. compile: pasmMod
  920.  
  921.  
  922. $ 1000    constant    kFloat        ¥ OR with a #cells parm for an EXTERN
  923.                                 ¥  to show that the parm is floating
  924.  
  925. from zCALLSMOD  import{  SYSCALL  KONST  $>KONST  LIBRARY  EXTERN  }
  926. compile: zCallsMod
  927.  
  928. ¥ compiling zCallsMod takes a long time, so we'll normally save
  929. ¥  the dic at this point.  Therefore we now define a new RUN word.
  930.  
  931.  
  932. : init2            ¥ our second stage initialization word
  933.     init1                        ¥ do the 1st stage initialization
  934.     0 -> bufPtr  0 -> hiCDP        ¥ for interpreting message binds
  935.     instld? NIF  " mops.paths" getPaths  THEN
  936.             ¥ add any other special class or module initialization here.
  937. ;
  938.  
  939. : cl2            ¥ our second stage cleanup word
  940.     unmod  cl1  ;
  941.  
  942. ' cl2  -> abortVec
  943.  
  944.  
  945. :f RUN
  946.     init2
  947.     cr ." This is Mike's interim nucleus."
  948.     cr ." Type // ppcb.ld" cr
  949.     QUIT
  950. ;f
  951.  
  952.  
  953. endload
  954.  
  955.  
  956.  
  957. ¥ More testing stuff:
  958.  
  959. +echo
  960.  
  961.  
  962. :class    HAHA    super{ int }
  963.  
  964. callLast    print:
  965.  
  966. :m BAtest:
  967.     1 2 3 . . .  ;m
  968. ;class
  969.  
  970. :class SUBHAHA  super{ haha }
  971.  
  972. callLast    dump:
  973.  
  974. :m BAtest:  -9 -8 -7 . . .  ;m
  975.  
  976. ;class
  977.  
  978. haha    hh
  979. subhaha    ss
  980.  
  981. : q batest: hh  batest: ss  ;
  982.  
  983.  
  984. : QQ    ." QQ here.  Hello. "  ;        ¥ This gets called from testMod
  985.  
  986. variable VB
  987.  
  988. compile: testmod2
  989.